home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / fngen.lsp < prev    next >
Lisp/Scheme  |  1992-08-28  |  7KB  |  205 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; GET-FUNCTION is the main user interface to this code.  If it is called
  32. ;;; with a lambda expression only, it will return a corresponding function.
  33. ;;; The optional constant-converter argument, can be a function which will
  34. ;;; be called to convert each constant appearing in the lambda to whatever
  35. ;;; value should appear in the function.
  36. ;;;
  37. ;;; Whether the returned function is actually compiled depends on whether
  38. ;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of
  39. ;;; code was precompiled.
  40. ;;; 
  41. (defun get-function (lambda
  42.               &optional (test-converter     #'default-test-converter)
  43.                         (code-converter     #'default-code-converter)
  44.                 (constant-converter #'default-constant-converter))
  45.   (apply-function (get-function-generator lambda test-converter code-converter)
  46.           (compute-constants      lambda constant-converter)))
  47.  
  48. (declaim (ftype (function (T &optional T T T) (values function T))
  49.                 get-function1))
  50. (defun get-function1 (lambda
  51.               &optional (test-converter     #'default-test-converter)
  52.                         (code-converter     #'default-code-converter)
  53.                 (constant-converter #'default-constant-converter))
  54.   (values (the function
  55.                (get-function-generator lambda test-converter code-converter))
  56.       (compute-constants      lambda constant-converter)))
  57.  
  58. (defun default-constantp (form)
  59.   ;; Replace constants by reference .constant. to stop similar code from
  60.   ;; being compiled in the future?
  61.   (and (constantp form)
  62.        (if (eq *compiler-speed* :slow)
  63.            (not (symbolp (eval form)))
  64.            (not (typep (eval form) '(or symbol fixnum))))))
  65.  
  66. (defun default-test-converter (form)
  67.   (if (default-constantp form)
  68.       '.constant.
  69.       form))
  70.  
  71. (declaim (ftype (function (T) (values T list)) default-code-converter))
  72. (defun default-code-converter  (form)
  73.   (if (default-constantp form)
  74.       (let ((gensym (gensym))) (values gensym (list gensym)))
  75.       (values form nil)))
  76.  
  77. (defun default-constant-converter (form)
  78.   (if (default-constantp form)
  79.       (list (eval form))
  80.       nil))
  81.  
  82.  
  83. ;;;
  84. ;;; *fgens* is a list of all the function generators we have so far.  Each 
  85. ;;; element is a FGEN structure as implemented below.  Don't ever touch this
  86. ;;; list by hand, use STORE-FGEN.
  87. ;;;
  88. (defvar *fgens* ())
  89.  
  90. (defun store-fgen (fgen)
  91.   (setq *fgens* (nconc *fgens* (list fgen))))
  92.  
  93. (defun lookup-fgen (test)
  94.   (find test (the list *fgens*) :key #'fgen-test :test #'equal))
  95.  
  96. (defun make-fgen (test gensyms generator generator-lambda system)
  97.   (let ((new (make-array 6)))
  98.     (setf (svref new 0) test
  99.       (svref new 1) gensyms
  100.       (svref new 2) generator
  101.       (svref new 3) generator-lambda
  102.       (svref new 4) system)
  103.     new))
  104.  
  105. (defun fgen-test             (fgen) (svref fgen 0))
  106. (defun fgen-gensyms          (fgen) (svref fgen 1))
  107. (defun fgen-generator        (fgen) (svref fgen 2))
  108. (defun fgen-generator-lambda (fgen) (svref fgen 3))
  109. (defun fgen-system           (fgen) (svref fgen 4))
  110.  
  111.  
  112.  
  113. (defun get-function-generator (lambda test-converter code-converter)
  114.   (let* ((test (compute-test lambda test-converter))
  115.      (fgen (lookup-fgen test)))
  116.     (if fgen
  117.     (fgen-generator fgen)
  118.     (get-new-function-generator lambda test code-converter))))
  119.  
  120. (declaim (ftype (function (T T) (values T list))
  121.                 get-new-function-generator-internal
  122.                 compute-code))
  123.  
  124. (defun get-new-function-generator (lambda test code-converter)
  125.   (multiple-value-bind (gensyms generator-lambda)
  126.       (get-new-function-generator-internal lambda code-converter)
  127.     (let* ((generator (compile-lambda generator-lambda))
  128.        (fgen (make-fgen test gensyms generator generator-lambda nil)))
  129.       (store-fgen fgen)
  130.       generator)))
  131.  
  132. (defun get-new-function-generator-internal (lambda code-converter)
  133.   (multiple-value-bind (code gensyms)
  134.       (compute-code lambda code-converter)
  135.     (values gensyms `(lambda ,gensyms (function ,code)))))
  136.  
  137.  
  138. (defun compute-test (lambda test-converter)
  139.   (let ((walk-form-expand-macros-p t))
  140.     (walk-form lambda
  141.            nil
  142.            #'(lambda (f c e)
  143.            (declare (ignore e))
  144.            (if (neq c :eval)
  145.                f
  146.                (let ((converted (funcall test-converter f)))
  147.              (values converted (neq converted f))))))))
  148.  
  149. (defun compute-code (lambda code-converter)
  150.   (let ((walk-form-expand-macros-p t)
  151.     (gensyms ()))
  152.     (values (walk-form lambda
  153.                nil
  154.                #'(lambda (f c e)
  155.                (declare (ignore e))
  156.                (if (neq c :eval)
  157.                    f
  158.                    (multiple-value-bind (converted gens)
  159.                    (funcall code-converter f)
  160.                  (when gens (setq gensyms (append gensyms gens)))
  161.                  (values converted (neq converted f))))))
  162.           gensyms)))
  163.  
  164. (defun compute-constants (lambda constant-converter)
  165.   (let ((walk-form-expand-macros-p t)) ; doesn't matter here.
  166.     (macrolet ((appending ()
  167.          `(let ((result ()))
  168.            (values #'(lambda (value) (setq result (append result value)))
  169.             #'(lambda ()result)))))
  170.       (gathering1 (appending)
  171.           (walk-form lambda
  172.                  nil
  173.                  #'(lambda (f c e)
  174.                  (declare (ignore e))
  175.                  (if (neq c :eval)
  176.                      f
  177.                      (let ((consts (funcall constant-converter f)))
  178.                        (if consts
  179.                        (progn (gather1 consts) (values f t))
  180.                        f)))))))))
  181.  
  182.  
  183. ;;;
  184. ;;;
  185. ;;;
  186. (defmacro precompile-function-generators (&optional system)
  187.   (make-top-level-form `(precompile-function-generators ,system)
  188.                '(load)
  189.     `(progn ,@(gathering1 (collecting)
  190.         (dolist (fgen *fgens*)
  191.           (when (or (null (fgen-system fgen))
  192.                 (eq (fgen-system fgen) system))
  193.             (when system (setf (svref fgen 4) system))
  194.             (gather1
  195.              `(load-function-generator
  196.                ',(fgen-test fgen)
  197.                ',(fgen-gensyms fgen)
  198.                (function ,(fgen-generator-lambda fgen))
  199.                ',(fgen-generator-lambda fgen)
  200.                ',system))))))))
  201.  
  202. (defun load-function-generator (test gensyms generator generator-lambda system)
  203.   (store-fgen (make-fgen test gensyms generator generator-lambda system)))
  204.  
  205.